
\ Define a word which executes the xt found at an offset `u` from the
\ base address stored at `addr`.
: dispatcher ( addr u "name" -- addr u' )
	create 2dup swap 2,  cell+
	does> ( -- )  2@ @ + @ execute ;
\ In the table at `addr`, set `xt` as the value for the `dispatcher`.
: implemented ( addr xt xt.dispatcher -- addr )
	>r over r> >body cell+ @ + ! ;
: implements ( addr xt "name" -- addr ) ' implemented ;
\ allocate `u` address units for a dispatch table which stores its base
\ address at `addr`.
: dispatch-table ( addr u "name" -- addr2 )
	create swap ,  here swap allot
	does> ( -- )  dup cell+ swap @ ! ;

: dir++ ( c-addr u  c-addr2 u2 -- c-addr' u' )  s++ dirsep c++ ;
align here filename-max dup chars allot 2constant tmp-filename
\ ${PKG-ROOT}/pkg/FOO/
: pkg-dir ( c-addr u -- c-addr' u' )
	2>r tmp-filename 2dup
		pkg-root s++  s" pkg" dir++
		2r> dup if dir++ else 2drop then
	nip - ;
\ ${PKG-ROOT}/supply/FOO
: db-file ( c-addr u -- c-addr' u' )
	tmp-filename 2tuck
		pkg-root s++  s" supply" dir++  2swap s++
	nip - ;
\ ${PKG-ROOT}/src/FOO
: pkg-src-file ( c-addr u -- c-addr' u' )
	2>r tmp-filename 2dup
		pkg-root s++  s" src" dir++  2r> s++
	nip - ;
\ munge word to filename and append ".fs".
: pkg-spec-file ( c-addr u -- c-addr' u' )
	tmp-filename  2tuck
		2tuck phrase>path nip /string
		pkg-extension s++
	nip - ;


create pkg-path 4 1024 * new-path drop
: preferred ( c-addr u -- )  pkg-dir pkg-path prepend-dir ;
: prefer ( "...<cr>" -- )  parse-line preferred ;
: reset-pkg-path ( -- )  pkg-path empty-path s" " preferred ;
reset-pkg-path


: src-included ( c-addr u -- )  pkg-src-file included ;
: include-src ( "filename<cr>" -- )  parse-line src-included ;
create src-line-buf filename-max 2 + chars allot
: type-pkg-src-file ( c-addr u -- )
	pkg-src-file r/o open-file abort" no such package source file"
	begin
		src-line-buf 2dup filename-max rot read-line
		abort" failed to read source line" while
			type cr
	repeat 2drop close-file abort" can't close file" ;
: type-input ( -- )
	begin
		source >in @ /string type cr
	refill 0= until ;


create name-buf 1024 chars allot
	here variable cur-name cur-name !
: name-space ( -- u )  cur-name @ name-buf - ;
: new-name ( c-addr u -- c-addr' u )
	cur-name @  over chars -  dup cur-name !
	swap 2dup 2>r chars move 2r> ;
: fits-w/dirs ( u pkg-path -- )
	max-dir-len + name-space u> abort" buffer overflow" ;

: ?included ( c-addr u -- n.err )
	['] included catch dup if nip nip then ;
: ?choose-dependencies ( addr.pkg -- n.err )
	@pkg-filename ?included ;
: ?choose-package ( c-addr.pkg u1 c-addr.file u2 -- c-addr.pkg u1 n.err )
	2over drop cur-name !
	2dup pkg-spec-seen? if 2drop -1 else mark >r  \ loop detected
		2over pkg-seen  dup ?choose-dependencies
		tuck if r> backtrack else choose-package r> then drop
	then ;

: (demanded) ( c-addr u -- )
	2dup pkg-chosen? if 2drop else 
		cur-name @ >r  new-name
		2dup pkg-spec-file dup pkg-path fits-w/dirs
		new-name pkg-path ['] ?choose-package find-in-path
		r> cur-name !  throw  2drop
	then ;


variable pkg-parser  pkg-parser 0
	dispatcher demanded ( c-addr u -- )
	dispatcher supplied-by ( -- )
	dispatcher file-supplied ( c-addr u -- )
constant /parser-xts drop
: demand ( "...<cr>" -- )  parse-line demanded ;
: supplied-by-file ( "...<cr>" -- )  parse-line file-supplied ;
pkg-parser /parser-xts dispatch-table check-deps
	' (demanded) implements demanded
	' \s implements supplied-by
	' 2drop implements file-supplied
drop
defer load-packages ( -- )
: user-demanded ( c-addr u -- )
	pkg-parser @ >r check-deps
		mark >r  (demanded) load-packages  r> backtrack
	r> pkg-parser ! ;
pkg-parser /parser-xts dispatch-table user-parser
	' user-demanded implements demanded
	' \s implements supplied-by
	' 2drop implements file-supplied
drop
user-parser

variable pkg-loader
pkg-loader /parser-xts dispatch-table interpret-pkgs
	' 2drop implements demanded
	' noop implements supplied-by
	' src-included implements file-supplied
drop
pkg-loader /parser-xts dispatch-table compile-pkgs
	' 2drop implements demanded
	' type-input implements supplied-by
	:noname ." include-src " type cr ; implements file-supplied
drop
pkg-loader /parser-xts dispatch-table compile-static-pkgs
	' 2drop implements demanded
	' type-input implements supplied-by
	' type-pkg-src-file implements file-supplied
drop
interpret-pkgs

: load-package ( addr.pkg -- )
	pkg-parser @ >r  pkg-loader @ pkg-parser !
		dup @pkg-filename ['] included catch
	r> pkg-parser !  throw  pkg-loaded ;
:noname ( -- )
	pkgs-chosen begin @ ?dup while
		dup load-package
	repeat  pkgs-chosen empty-queue ; is load-packages


: include-supply ( c-addr u -- )  db-file included ;
: demanded>file ( c-addr.pkg u.pkg  c-addr.file u.file -- )
	w/o create-file throw  dup >r
		['] demanded swap outfile-execute
	r> close-file throw ;
: make-load-file ( c-addr.pkg u.pkg c-addr.file u.file -- )
	here >r 2swap allot-chars 2swap
	pkg-loader @ >r compile-static-pkgs
		s" marker <<demand>>" evaluate
			2dup include-supply  demanded>file
		s" <<demand>>" evaluate
		0 pkgs-available !  reset-pkg-path
	r> pkg-loader !  here r> - allot ;
: make-load-files ( c-addr.pkg u.pkg -- )
	2dup s" gforth.fs" make-load-file
	2dup s" iforth.fs" make-load-file
	2dup s" pforth.fs" make-load-file
	2dup s" swiftforth.fs" make-load-file
	2dup s" vfxforth.fs" make-load-file
	s" win32forth.fs" make-load-file ;
